perm filename CLIP.BCH[TIM,LSP] blob
sn#612203 filedate 1981-09-14 generic text, type T, neo UTF8
;;;-*-lisp-*-
;;; The GJC lisp benchmarks.
;; This benchmark tests raw structure referencing, function calling,
;; dispatching, and arithmetic speed. Tail recursion optimization
;; and good register allocation are also applicable.
;; A CLIPPER does line-clipping by a half-plane, they may be
;; cascaded to clip for arbitrary convex windows.
;; The equation of the half plane is A*X+B*Y<C
;; If the line is given by the two point formula
;; Y2 - Y1 Y1 - Y
;; ------- = ------
;; X2 - X1 X1 - X
;; And the edge of the half plane by
;; B Y + A X = C
;; Then the intercept is
;; B (X1 Y2 - X2 Y1) + C (X2 - X1) A (X2 Y1 - X1 Y2) + C (Y2 - Y1)
;; X = ------------------------------- Y = -------------------------------
;; B (Y2 - Y1) + A (X2 - X1) B (Y2 - Y1) + A (X2 - X1)
#.(PROGN #+Maclisp (sstatus feature numdcl)
#+Maclisp (sstatus feature subrcall)
#+Lispm (sstatus feature arithcheck)
nil)
#+numdcl
(DECLARE (FLONUM (DIST FLONUM FLONUM FLONUM FLONUM)
(DET FLONUM FLONUM FLONUM FLONUM)
#+arithcheck (C-QUOTIENT-INTERNAL FLONUM FLONUM)
(X-INTERCEPT-N FLONUM FLONUM FLONUM FLONUM FLONUM)))
(DEFUN DIST (A X B Y) (PLUS (TIMES A X) (TIMES B Y)))
(DEFUN DET (X1 Y1 X2 Y2) (DIFFERENCE (TIMES X1 Y2) (TIMES X2 Y1)))
(DEFUN X-INTERCEPT-N (X1 X2 DET B C)
(PLUS (TIMES B DET)
(TIMES C (DIFFERENCE X2 X1))))
(DEFMACRO X-INTERCEPT (X1 X2 DET B C Q)
`(C-QUOTIENT (X-INTERCEPT-N ,X1 ,X2 ,DET ,B ,C) ,Q))
(DEFMACRO Y-INTERCEPT (Y1 Y2 DET A C Q)
`(C-QUOTIENT (X-INTERCEPT-N ,Y1 ,Y2 (MINUS ,DET) ,A ,C) ,Q))
(DEFMACRO C-QUOTIENT (X Y)
#-arithcheck `(quotient ,x ,y)
#+arithcheck `(c-quotient-internal ,x ,y))
#+arithcheck
(progn 'compile
(defvar epsilon 0.00001)
#+numdcl (declare (flonum epsilon))
(defun c-quotient-internal (x y)
(if (lessp (abs x) epsilon) x (quotient x y)))
)
(DEFVST CLIPPER
(EXPR #'CLIPPER)
#+subrcall SUBR
S
A
B
C)
(DEFMACRO MAKE-CLIPPER (&REST L) `(SETTUP-CLIPPER (CONS-A-CLIPPER ,@L)))
(DEFUN SETTUP-CLIPPER (SELF)
#+SUBRCALL (SETF (CLIPPER-SUBR SELF)
(GETSUBR (CLIPPER-EXPR SELF)))
SELF)
(DEFUN CLIPPER (SELF X1 Y1 X2 Y2)
#+numdcl (DECLARE (FLONUM X1 Y1 X2 Y2))
(LET ((A (CLIPPER-A SELF))
(B (CLIPPER-B SELF))
(C (CLIPPER-C SELF))
(S (CLIPPER-S SELF)))
#+numdcl (DECLARE (FLONUM A B C))
(LET ((D1 (DIST A X1 B Y1))
(D2 (DIST A X2 B Y2)))
#+numdcl (DECLARE (FLONUM D1 D2))
(COND ((LESSP D1 C)
(IF (LESSP D2 C)
(CLIPPER-CALL S X1 Y1 X2 Y2)
(LET ((Q (DIFFERENCE D1 D2))
(D (DET X1 Y1 X2 Y2)))
#+numdcl (DECLARE (FLONUM Q D))
(CLIPPER-CALL
S X1 Y1
(X-INTERCEPT X1 X2 D B C Q)
(Y-INTERCEPT Y1 Y2 D A C Q)))))
((LESSP D2 C))
(T
(LET ((Q (DIFFERENCE D1 D2))
(D (DET X1 Y1 X2 Y2)))
#+numdcl (DECLARE (FLONUM Q D))
(CLIPPER-CALL
S
(X-INTERCEPT X1 X2 D B C Q)
(Y-INTERCEPT Y1 Y2 D A C Q)
X2 Y2)))))))
(DEFUN DRAW-LINE (IGNORE-SELF IGNORE2 IGNORE3 IGNORE4 IGNORE5) NIL)
(DEFUN CLIPPER-CALL (CLIPPER X1 Y1 X2 Y2)
#+subrcall
(subrcall nil (clipper-subr clipper) clipper x1 y1 x2 y2)
#-subrcall
(funcall (clipper-expr clipper) clipper x1 y1 x2 y2)
)
#+subrcall
(PROGN 'COMPILE
(DEFUN TRAMP (SELF X1 Y1 X2 Y2)
(FUNCALL (CLIPPER-EXPR SELF) SELF X1 Y1 X2 Y2))
(DEFVAR GETSUBR T)
(DEFUN GETSUBR (X)
(OR (AND GETSUBR (ATOM X) (GET X 'SUBR))
(GET 'TRAMP 'SUBR)
(GETSUBR (ERROR "No Trampoline" 'TRAMP 'WRNG-TYPE-ARG))))
)
; Simulation package. -*-Mode:LISP; Base:10-*-
; This file includes:
; 1. Random number utilities.
; 2. A simulation driver.
; 3. A queue manager.
; 4. A simple M/M/1 test system.
; Set reasonable number base.
(eval-when (compile load eval)
(setq base (+ 8 2) ibase (+ 8 2) *nopoint t))
; Output macros to FASL file.
#m(declare (macros t))
#m(eval-when (compile load eval)
(load "alan;struct fasl"))
(defmacro increment (var &optional (delta 1))
`(setf ,var (+ ,var ,delta)))
(defmacro decrement (var &optional (delta 1))
`(setf ,var (- ,var ,delta)))
#m(declare (flonum (random-float flonum)))
(defun random-float ()
(//$ (float (1+ (random 1000000)))
1000000.0))
#m(declare (flonum (random-exponential flonum)))
(defun random-exponential (mean)
(-$ (*$ (log (random-float))
mean)))
(defun test (form &optional (N 1000))
(prog (sum sumsq)
(setq sum 0.0 sumsq 0.0)
(do i N (1- i) (= i 0)
(let ((x (eval form)))
(setq sum (+$ sum x))
(setq sumsq (+$ sumsq (*$ x x)))
))
(let ((x (//$ sum (float N))))
(let ((y (sqrt (-$ (//$ sumsq (float N))
(*$ x x)))))
(terpri)
(format t "Average = }s, standard deviation = }s" x y)))))
;;; This program is henceforth called: ``SAIL constraint combinatorial pairing
;;; program'' or SCCPP.
;;;First, in SCCPP there are functions with 7 arguments. For example,
;;;the first function starts out:
;;;
;;;(DEFUN PAIRS
;;; (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;; NIL-PAIRS) ...)
;;;
;;;I suggest the following translation:
;;;
;;;(DEFUN PAIRS n
;;; ((LAMBDA (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;; NIL-PAIRS) ...)
;;; (ARG 1)(ARG 2)(ARG 3)(ARG 4)(ARG 5)(ARG 6)(ARG 7)))
;;;
;;;(*list a1 ... an) => (cons a1 (cons a2 ...(cons an-1 an)))
;;;
;;;(*catch x y) evaluates the form y. x should EVAL to a tag. If y returns
;;;normally, the value of the *catch is the value of y. If the evaluation
;;;of y entails the evaluation of a form like (*throw q v) where q EVALs
;;;to the same tag that x did, then v is evaluated and the value of the *catch
;;;is the value of v. Unless, there is an intervening *catch with the same
;;;tag...
;;;
;;;MAPCAN is MAPCAR with NCONC instead of CONS.
;;;
;;;1+, +, < etc are FIXNUM versions of ADD1, PLUS, LESSP etc.
;;;
;;;(FUNCALL fun x1 ... xn) evaluates all of its arguments and
;;;applies the value of fun to the arguments x1 ... xn. So
;;;(FOO a b c d) = (FUNCALL 'FOO a b c d)
;;;
;;; -rpg-
(DEFUN PAIRS (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
((LAMBDA (XXX)
(MAPCAN
(FUNCTION(LAMBDA (I)
(PROGN
(COND
(MUST-APPEAR
(*CATCH
'OUT
(PROGN
(MAPC
(FUNCTION(LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR)
(*THROW 'OUT T)))))
I)
NIL)))
(T)))
(LIST I)))
XXX))
(MAPCAR (FUNCTION(LAMBDA (I) (CDR I)))
(COND ((< (LENGTH X)
(+ (COND (NIL-PAIRS 1) (T 0)) (LENGTH Y)))
(PAIRS1 (MAKE-POSSIBILITY-1 X
Y
FUN
APPLY-CONSTRAINTS
CONSTRAINTS
NIL-PAIRS)))
(T (PAIRS2 (MAKE-POSSIBILITY-2 Y
X
FUN
APPLY-CONSTRAINTS
CONSTRAINTS
NIL-PAIRS)))))))
(DEFUN MAKE-POSSIBILITY-1 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
((LAMBDA (N)
((LAMBDA (Q)
(COND
(NIL-PAIRS (MAPC (FUNCTION(LAMBDA (I) (RPLACD I
(LIST* '(NIL)
(CDR I)))))
Q))
(Q)))
(MAPCAN
(FUNCTION(LAMBDA (I)
(PROGN
(SETQ N 0)
((LAMBDA (A) (AND A
(OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(FUNCALL APPLY-CONSTRAINTS
CONSTRAINTS))
(LIST (LIST* I A))))
(MAPCAN
(FUNCTION(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (SETQ N (1+ N))
(COND ((OR (NULL FUN)
(FUNCALL FUN I J))
(LIST* N J)))))))
Y)))))
X)))
0))
(DEFUN MAKE-POSSIBILITY-2 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
((LAMBDA (N)
((LAMBDA (Q)
(COND
(NIL-PAIRS (MAPC (FUNCTION(LAMBDA (I) (RPLACD I
(LIST* '(NIL)
(CDR I)))))
Q))
(Q)))
(MAPCAN
(FUNCTION(LAMBDA (I)
(PROGN
(SETQ N 0)
((LAMBDA (A) (AND A
(OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(FUNCALL APPLY-CONSTRAINTS
CONSTRAINTS))
(LIST (LIST* I A))))
(MAPCAN
(FUNCTION(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (SETQ N (1+ N))
(COND ((OR (NULL FUN)
(FUNCALL FUN J I))
(LIST* N J)))))))
Y)))))
X)))
0))
(DEFUN PAIRS1 (L)
(COND
((NULL L) '((NIL)))
(T
((LAMBDA (CAND POSS)
(MAPCAN
(FUNCTION(LAMBDA (PAIRS)
(PROGN
((LAMBDA (AVOID ANS)
(MAPCAN
(FUNCTION(LAMBDA (I)
((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (COND ((CAR (MEMBER (CAR I)
AVOID))
(LIST* AVOID ANS))
(T (LIST* (LIST* (CAR I)
AVOID)
(LIST* CAND
(CDR I))
ANS)))))))
POSS))
(CAR PAIRS)
(CDR PAIRS)))))
(PAIRS1 (CDR L))))
(CAAR L)
(CDAR L)))))
(DEFUN PAIRS2 (L)
(COND
((NULL L) '((NIL)))
(T
((LAMBDA (CAND POSS)
(MAPCAN
(FUNCTION(LAMBDA (PAIRS)
(PROGN
((LAMBDA (AVOID ANS)
(MAPCAN
(FUNCTION(LAMBDA (I)
((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (COND ((CAR (MEMBER (CAR I)
AVOID))
(LIST* AVOID ANS))
(T (LIST* (LIST* (CAR I)
AVOID)
(LIST* (CDR I)
CAND)
ANS)))))))
POSS))
(CAR PAIRS)
(CDR PAIRS)))))
(PAIRS2 (CDR L))))
(CAAR L)
(CDAR L)))))
(declare (special a b))
(setq a '(
(1 2)
(7 8)
(9 0)
(a b c)
(a b c)
(d e f)
(d e f)
(g h i)
(g h i)
(j k l)
(m n o)
(p q r)
))
(setq b '(
(a b c)
(j k l)
(d e f)
(p q r)
(g h i)
(9 0)
(a b c)
(p q r)
(7 8)
(j k l)
(2 1)
(3 2)
(8 7)
(9 8)
(0 9)
(m n o)
(d e f)
(j k l)
(m n o)
(d e f)
(p q r)
(g h i)
))
(defun test ()
((lambda (t1 x gt)
(setq x (pairs a b () 'equal () () ()))
(setq t1 (- (runtime) t1))
(setq gt (- (status gctime) gt))
(print (length x))
(print (list 'runtime
(QUOTIENT (FLOAT (- t1 gt))
1000000.)))
(print (list 'gctime
(quotient (float gt) 1000000.))))
(runtime) ()(status gctime)))
FRANZ Benchmark (called FRPOLY)
Here, below, is the benchmark from Berkeley. It is in roughly
MacLisp syntax, but let me point out a few things about it.
First, DEFMACRO and the ` (backquote) syntax. DEFMACRO is
a mechanism for defining macros in MacLisp in which the form
is broken into named arguments, unlike standard MacLisp macros
with have exactly 1 argument which is the macro form itself (EQly
that form). The backquote syntax takes a form and produces code
to generate that form. A example helpe here:
`(atom ,e) turns into (list 'atom e)
`(signp e ,x) is (list 'signp 'e x)
Thus, , (comma) is the unquoting character.
For example, then, occurrences of (pcoefp x) in the code
below turn into (atom x) by the action of the macro
pcoefp. DEFMACRO provides a form which is substituted for
the calling form with arguments bound in the obvious manner.
Here is the equivalent standard MacLisp macro definition of
pcoefp:
(defun pcoefp macro (x)
(list 'atom (cadr x)))
To run this benchmark interpretively, I suggest expanding the
macros once, either at read time or at first runtime. For those
who need it I can provide this file with macros expanded.
Another hack for defining these macros so that they are expanded
once only is:
(defun pcoefp macro (x)
((lambda (form)
(rplaca x (car form))
(rplacd x (cdr form))
form) ;value of RPLACD assumed to be undefined
(list 'atom (cadr x))))
LOCALF seems to be a declaration of LOCAL function names. For MacLisp
I've commented this out. SPECIAL means that there is a global
value cell and that binding is dynamic on that cell.
Here is what SIGNP does:
2) SIGNP IS NOW A FSUBR. THE FIRST ITEM IN THE ARGLIST IS AN
INDICATOR FOR COMPARISON TO ZERO, E.G., (SIGNP LE N) IS NON-NIL
IF AND ONLY IF THE VALUE OF N IS A NUMBER LESS THAN OR EQUAL TO
ZERO [SIGNP DOES NOT REQUIRE N TO BE OF NUMBER TYPE]. THE
INDICATORS FOLLOW THE PDP-10 ARITHMETIC COMPARISON INSTRUCTIONS, AND
SHOULD BE SELF EXPLANATORY: L E LE GE N G
[E means zerop, N means not zerop.]
(RUNTIM) and (STATUS GCTIME) return the number of microseconds of
total runtime and gctime. Note that gctime is included in
runtime in MacLisp.
There is a difference between `+' and `PLUS' in Franz, which is
that + takes 2 arguments, both fixnums (machine integers) and returns
a fixnum as its result. PLUS takes any number of any type of number and
returns the most appropriate type number. In the tests below, one of them
is designed to overflow the VAX machine integer range and drift into
BIGNUMs, which are any integer larger than the architecture supports. In MacLisp
and FRANZ there is a BIGNUM packake that allows one to have contiguous
words of memory represent one number. So, beware of where there are +'s and
PLUS's. The same is true for - and DIFFERENCE, * and TIMES, / and QUOTIENT,
> and GREATERP, < and LESSP, etc. Generic arithmetic is closed compiled
while specific type is open coded.
(ODPP x) tests if X is odd.
= is numeric EQUAL.
PDIFFER1 is mentioned but not defined; is not called for these tests, however.
Here's my transcript of SAIL MacLisp:
(setup)
(Z 1 1.0 0 (Y 1 1.0 0 (X 1 1.0 0 1.0)))
(bench 2)
(POWER= 2 (0.017 0.0) (0.017 0.0) (0.016 0.0))
(bench 5)
(POWER= 5 (0.116 0.0) (1.334 1.084) (0.15 0.0))
(bench 10)
(POWER= 10 (2.534 1.8) (19.733 17.151) (8.983 7.901))
(bench 15)
(POWER= 15 (16.65 8.832) (112.516 89.298) (63.9 56.749))
Which I ran compiled. Times are in seconds.
The following is the benchmark.
-rpg-
;;;; Benchmark Commences:
;;; Franz Lisp benchmark from Fateman
;; test from Berkeley based on polynomial arithmetic.
(declare (special ans coef f inc i k qq ss v *x*
*alpha *a* *b* *chk *l *p q* u* *var *y*
r r2 r3 start res1 res2 res3))
(declare (localf pcoefadd pcplus pcplus1 pplus ptimes ptimes1
ptimes2 ptimes3 psimp pctimes pctimes1
pplus1))
;; Franz uses maclisp hackery here; you can rewrite lots of ways.
(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
(defmacro pcoefp (e) `(atom ,e))
(defmacro pzerop (x) `(signp e ,x)) ;true for 0 or 0.0
(defmacro pzero () 0)
(defmacro cplus (x y) `(plus ,x ,y))
(defmacro ctimes (x y) `(times ,x ,y))
(defun pcoefadd (e c x) (cond ((pzerop c) x)
(t (cons e (cons c x)))))
(defun pcplus (c p) (cond ((pcoefp p) (cplus p c))
(t (psimp (car p) (pcplus1 c (cdr p))))))
(defun pcplus1 (c x)
(cond ((null x)
(cond ((pzerop c) nil) (t (cons 0 (cons c nil)))))
((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil))
(t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))
(defun pctimes (c p) (cond ((pcoefp p) (ctimes c p))
(t (psimp (car p) (pctimes1 c (cdr p))))))
(defun pctimes1 (c x)
(cond ((null x) nil)
(t (pcoefadd (car x)
(ptimes c (cadr x))
(pctimes1 c (cddr x))))))
(defun pplus (x y) (cond ((pcoefp x) (pcplus x y))
((pcoefp y) (pcplus y x))
((eq (car x) (car y))
(psimp (car x) (pplus1 (cdr y) (cdr x))))
((pointergp (car x) (car y))
(psimp (car x) (pcplus1 y (cdr x))))
(t (psimp (car y) (pcplus1 x (cdr y))))))
(defun pplus1 (x y)
(cond ((null x) y)
((null y) x)
((= (car x) (car y))
(pcoefadd (car x)
(pplus (cadr x) (cadr y))
(pplus1 (cddr x) (cddr y))))
((> (car x) (car y))
(cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
(t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))
(defun psimp (var x)
(cond ((null x) 0)
((atom x) x)
((zerop (car x)) (cadr x))
(t (cons var x))))
(defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) (pzero))
((pcoefp x) (pctimes x y))
((pcoefp y) (pctimes y x))
((eq (car x) (car y))
(psimp (car x) (ptimes1 (cdr x) (cdr y))))
((pointergp (car x) (car y))
(psimp (car x) (pctimes1 y (cdr x))))
(t (psimp (car y) (pctimes1 x (cdr y))))))
(defun ptimes1 (*x* y) (prog (u* v)
(setq v (setq u* (ptimes2 y)))
a (setq *x* (cddr *x*))
(cond ((null *x*) (return u*)))
(ptimes3 y)
(go a)))
(defun ptimes2 (y) (cond ((null y) nil)
(t (pcoefadd (plus (car *x*) (car y))
(ptimes (cadr *x*) (cadr y))
(ptimes2 (cddr y))))))
(defun ptimes3 (y)
(prog (e u c)
a1 (cond ((null y) (return nil)))
(setq e (+ (car *x*) (car y)))
(setq c (ptimes (cadr y) (cadr *x*) ))
(cond ((pzerop c) (setq y (cddr y)) (go a1))
((or (null v) (> e (car v)))
(setq u* (setq v (pplus1 u* (list e c))))
(setq y (cddr y)) (go a1))
((= e (car v))
(setq c (pplus c (cadr v)))
(cond ((pzerop c) (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))))
(t (rplaca (cdr v) c)))
(setq y (cddr y))
(go a1)))
a (cond ((and (cddr v) (> (caddr v) e)) (setq v (cddr v)) (go a)))
(setq u (cdr v))
b (cond ((or (null (cdr u)) (< (cadr u) e))
(rplacd u (cons e (cons c (cdr u)))) (go e)))
(cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d))
(t (rplaca (cddr u) c)))
e (setq u (cddr u))
d (setq y (cddr y))
(cond ((null y) (return nil)))
(setq e (+ (car *x*) (car y)))
(setq c (ptimes (cadr y) (cadr *x*)))
c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c)))
(go b)))
(defun pexptsq (p n)
(do ((n (quotient n 2) (quotient n 2))
(s (cond ((oddp n) p) (t 1))))
((zerop n) s)
(setq p (ptimes p p))
(and (oddp n) (setq s (ptimes s p))) ))
(defun setup nil
(putprop 'x 1 'order)
(putprop 'y 2 'order)
(putprop 'z 3 'order)
(setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1
(setq r2 (ptimes r 100000)) ;r2 = 100000*r
(setq r3 (ptimes r 1.0)); r3 = r with floating point coefficients
)
; time various computations of powers of polynomials, not counting
;printing but including gc time ; provide account of g.c. time.
; The following function uses (ptime) for process-time and is thus
; Franz-specific.
(defmacro ptime () '`(,(runtime) ,(status gctime)))
(defun bench (n)
(setq start (ptime)) ; Franz ticks, 60 per sec, 2nd number is GC
(pexptsq r n)
(setq res1 (ptime))
(pexptsq r2 n)
(setq res2 (ptime))
; this one requires bignums.
(pexptsq r3 n)
(setq res3 (ptime))
(list 'power= n (b1 start res1)(b1 res1 res2)(b1 res2 res3)))
(defun b1(x y)(mapcar '(lambda(r s)(quotient (float (- s r)) 1000000.0)) x y))
;instructions:
; after loading, type (setup)
; then (bench 2) ; this should be pretty fast.
; then (bench 5)
; then (bench 10)
; then (bench 15)
;...
;; The actual test.
;; Remember, A*X+B*Y<C, so for horizonal and vertical lines,
;; B=0 Xc<C/A and A=0 Yc<C/B.
#.`',(SETQ ZERO 0.0 ONE 1.0 LOW 0.0 HI 1.0)
(DEFUN MAKE-TEST-CLIPPER ()
(MAKE-CLIPPER ; Y < HI
A #.ZERO
B #.ONE
C #.HI
S (MAKE-CLIPPER ; Y > LOW
A #.ZERO
B (MINUS #.ONE)
C #.LOW
S (MAKE-CLIPPER ; X < HI
A #.ONE
B #.ZERO
C #.HI
S (MAKE-CLIPPER ; X > LOW
A (MINUS #.ONE)
B #.ZERO
C #.LOW
S (MAKE-CLIPPER
EXPR #'DRAW-LINE))))))
(DEFVAR CLIPPER (MAKE-TEST-CLIPPER))
(DEFMACRO TIME-DIFFERENCE-NORMALIZE (X Y)
#+LISPM `(* (// 1000000. 60.) (TIME-DIFFERENCE ,X ,Y))
#+MACLISP `(- ,X ,Y)
#+NIL `(- ,X ,Y))
(DEFMACRO SYS-RUNTIME ()
#+LISPM '(TIME)
#+MACLISP '(RUNTIME)
#+NIL '(RUNTIME))
(DEFMACRO DEF-TEST-LOOP (NAME . BODY)
`(DEFUN (,NAME TEST-LOOP-EXPR #+subrcall TEST-LOOP-SUBR) (N)
(DECLARE (FIXNUM N))
(DO ((START-TIME (SYS-RUNTIME))
(J 1 (1+ J)))
((> J N)
(TIME-DIFFERENCE-NORMALIZE (SYS-RUNTIME) START-TIME))
(DECLARE (FIXNUM J))
,@BODY)))
#+NUMDCL (DECLARE (FLONUM (TESTPOINT)))
(DEFUN TESTPOINT ()
(DIFFERENCE (TIMES #.(PLUS ONE ONE ONE)
(FLOAT (RANDOM))
#.(QUOTIENT 1 (FLOAT (LSH -1 -1))))
#.ONE))
(DEF-TEST-LOOP CLIPPER-CALL
(CLIPPER-CALL CLIPPER
(TESTPOINT)
(TESTPOINT)
(TESTPOINT)
(TESTPOINT)))
(DEF-TEST-LOOP TESTPOINT
(TESTPOINT)
(TESTPOINT)
(TESTPOINT)
(TESTPOINT))
(DEFUN TEST-LOOP (NAME N)
(LET ((TIME (LET ((P (GETL NAME '(TEST-LOOP-EXPR #+subrcall TEST-LOOP-SUBR))))
(CASEQ (CAR P)
((TEST-LOOP-EXPR)
(FUNCALL (CADR P) N))
#+subrcall
((TEST-LOOP-SUBR)
(SUBRCALL NIL (CADR P) N))))))
(FORMAT MSGFILES
"}&}D loops in }D microseconds = }D microseconds per loop}%"
N TIME
(// TIME N))))
(DEFUN TEST-RUN (NAME END &OPTIONAL (START 1) (STEP 1))
(FORMAT MSGFILES
"}
}&Running clip test }S from }D to }D by step }D.}
}%----------------------------------------------------------}%"
NAME START END STEP)
(DO ((K START (+ K STEP))
(TIME (SYS-RUNTIME)))
((> K END)
(FORMAT MSGFILES
"}&------------------------------------------}
}%End of test, }D microseconds total.}%"
(time-difference-normalize (sys-runtime) time)))
(test-loop name k)))
; Simulation package. -*-Mode:LISP; Base:10-*-
; This file includes:
; 1. Random number utilities.
; 2. A simulation driver.
; 3. A queue manager.
; 4. A simple M/M/1 test system.
; Set reasonable number base.
(eval-when (compile load eval)
(setq base (+ 8 2) ibase (+ 8 2) *nopoint t))
; Output macros to FASL file.
#m(declare (macros t))
#m(eval-when (compile load eval)
(load "alan;struct fasl"))
(defmacro increment (var &optional (delta 1))
`(setf ,var (+ ,var ,delta)))
(defmacro decrement (var &optional (delta 1))
`(setf ,var (- ,var ,delta)))
#m(declare (flonum (random-float flonum)))
(defun random-float ()
(//$ (float (1+ (random 1000000)))
1000000.0))
#m(declare (flonum (random-exponential flonum)))
(defun random-exponential (mean)
(-$ (*$ (log (random-float))
mean)))
(defun test (form &optional (N 1000))
(prog (sum sumsq)
(setq sum 0.0 sumsq 0.0)
(do i N (1- i) (= i 0)
(let ((x (eval form)))
(setq sum (+$ sum x))
(setq sumsq (+$ sumsq (*$ x x)))
))
(let ((x (//$ sum (float N))))
(let ((y (sqrt (-$ (//$ sumsq (float N))
(*$ x x)))))
(terpri)
(format t "Average = }s, standard deviation = }s" x y)))))
;;; Simulation Driver
; EVENT-LIST is a list of (TIME . EVENT) pairs sorted by TIME.
; EVENT-AT-TIME adds to this list, and RUN removes things from it.
; It is initialized by RUN.
(declare (special event-list))
; (EVENT-AT-TIME EVENT TIME) causes EVENT to be funcall'd at TIME.
(defun event-at-time (event time)
(cond ((or (null event-list)
(> (caar event-list) time))
(setq event-list (cons (cons time event) event-list)))
(t (do ((i event-list (cdr i)))
((or (null (cdr i))
(> (caadr i) time))
(rplacd i (cons (cons time event) (cdr i))))
))))
; CURRENT-TIME is set by RUN, and read by many event subroutines. It
; represents time in the simulation run.
; CURRENT-EVENT is the name of the current event. It is currently used
; only in RUN.
(declare (special current-time current-event))
(defvar event-trace ())
; (RUN DURATION) does a simulation run, terminating after DURATION clock
; units. The user subroutine GENESIS is invoked at the beginning of time,
; and APOCALYPSE at the end of the simulation. APOCALYPSE should
; finish with (*THROW 'DONE ()) to exit RUN.
(defun run (duration)
(setq event-list ()) ; no events yet
(setq current-time 0) ; start time at zero for
; error check below
(event-at-time #'genesis 0) ; GENESIS will invoke other
; events
(event-at-time #'apocalypse duration) ; APOCALYPSE after the
; specified length of time
(*catch 'done
(do () ; loop
((null event-list) ; if EVENT-LIST becomes null
(format t "}%Premature end of world") ; then terminate abnormally
(apocalypse)) ; still call user subroutine
; get next event from EVENT-LIST and do it
(cond ((< (caar event-list) current-time)
(error "Attempt to warp time!")))
(setq current-time (caar event-list) ; set CURRENT-TIME to time of
; next event
current-event (cdar event-list) ; set CURRENT-EVENT to
; subroutine to call
event-list (cdr event-list))
(if event-trace
(format t "}%T = }s, calling }s" current-time current-event))
(funcall current-event)) ; call event subroutine
))
;;; Queues
(defstruct (queue #q :named)
(queue-list ())
(queue-length 0)
(queue-last-operation 0)
(queue-time-length-product 0)
(maximum-queue-length 0)
queue-name
)
(defun create-queue (name)
(make-queue queue-name name))
(defun update-queue-statistics (queue)
(increment (queue-time-length-product queue)
(* (- current-time (queue-last-operation queue))
(queue-length queue)))
(setf (queue-last-operation queue) current-time))
(defun enqueue (object queue)
(update-queue-statistics queue)
(setf (queue-list queue) (nconc (queue-list queue) (ncons object)))
(increment (queue-length queue))
(setf (maximum-queue-length queue) (max (maximum-queue-length queue)
(queue-length queue))))
(defun dequeue (queue)
(if (null (queue-list queue)) ; if nothing in queue
() ; return ()
(prog1 (car (queue-list queue))
(update-queue-statistics queue)
(setf (queue-list queue) (cdr (queue-list queue)))
(decrement (queue-length queue)))))
(defun print-queue-statistics (queue)
(update-queue-statistics queue)
(format t "}%}a length: average = }s, maximum = }s"
(queue-name queue)
(//$ (float (queue-time-length-product queue))
(float current-time))
(maximum-queue-length queue)))
;;; M/M/1 test system.
; Requests are currently just a fixnum. Should be a structure for
; tracking request service time, etc.
(defun create-request (service-time) service-time)
(defun service-time (request) request)
; Define/default mean service time and arrival rate.
(defvar mean-service-time 900.0)
(defvar mean-arrival-interval 1000.0)
(defun set-utilization (u)
(setq mean-service-time (*$ mean-arrival-interval u)))
(defvar busy) ; set if server is busy
(defvar server-queue) ; used to queue requests
; while server is busy
(defvar server-time) ; total time sever busy
(defvar start-of-service) ; time last service began
; Event for arrival of a new request.
(defun arrival ()
(let ((request (create-request (fix (random-exponential mean-service-time))))
(next (fix (random-exponential mean-arrival-interval))))
(event-at-time #'arrival (+ current-time next))
(if busy
(enqueue request server-queue)
(service request))
))
; Service a request.
(defun service (request)
(setq start-of-service current-time)
(setq busy t)
(event-at-time #'departure (+ current-time (service-time request))))
; Event for service completion. Update statistics and service next request
; in queue, if any.
(defun departure ()
(increment server-time (- current-time start-of-service))
(setq busy ())
(let ((request (dequeue server-queue)))
(if (not (null request))
(service request))))
(defun print-server-statistics ()
(if busy (increment server-time (- current-time start-of-service)))
(format t "}%server utilization = }s"
(//$ (float server-time) (float current-time))))
(defun Genesis ()
(format t "}%Begin queuing simulation with utilization = }s}%"
(//$ mean-service-time
mean-arrival-interval))
(setq server-queue (create-queue "server queue")) ; create queue
(setq busy ()) ; mark server as idle
(setq server-time 0)
(arrival)) ; start off with an arrival
(defun Apocalypse ()
(format t "}%End simulation at T = }s}%" current-time)
(print-server-statistics)
(print-queue-statistics server-queue)
(*throw 'done ()))
ββCOMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 This program is henceforth called: ``SAIL constraint combinatorial pairing
C00011 ENDMK
C⊗;
;;; This program is henceforth called: ``SAIL constraint combinatorial pairing
;;; program'' or SCCPP.
;;;First, in SCCPP there are functions with 7 arguments. For example,
;;;the first function starts out:
;;;
;;;(DEFUN PAIRS
;;; (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;; NIL-PAIRS) ...)
;;;
;;;I suggest the following translation:
;;;
;;;(DEFUN PAIRS n
;;; ((LAMBDA (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;; NIL-PAIRS) ...)
;;; (ARG 1)(ARG 2)(ARG 3)(ARG 4)(ARG 5)(ARG 6)(ARG 7)))
;;;
;;;(*list a1 ... an) => (cons a1 (cons a2 ...(cons an-1 an)))
;;;
;;;(*catch x y) evaluates the form y. x should EVAL to a tag. If y returns
;;;normally, the value of the *catch is the value of y. If the evaluation
;;;of y entails the evaluation of a form like (*throw q v) where q EVALs
;;;to the same tag that x did, then v is evaluated and the value of the *catch
;;;is the value of v. Unless, there is an intervening *catch with the same
;;;tag...
;;;
;;;MAPCAN is MAPCAR with NCONC instead of CONS.
;;;
;;;1+, +, < etc are FIXNUM versions of ADD1, PLUS, LESSP etc.
;;;
;;;(FUNCALL fun x1 ... xn) evaluates all of its arguments and
;;;applies the value of fun to the arguments x1 ... xn. So
;;;(FOO a b c d) = (FUNCALL 'FOO a b c d)
;;;
;;; -rpg-
(DEFUN PAIRS (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
((LAMBDA (XXX)
(MAPCAN
(FUNCTION(LAMBDA (I)
(PROGN
(COND
(MUST-APPEAR
(*CATCH
'OUT
(PROGN
(MAPC
(FUNCTION(LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR)
(*THROW 'OUT T)))))
I)
NIL)))
(T)))
(LIST I)))
XXX))
(MAPCAR (FUNCTION(LAMBDA (I) (CDR I)))
(COND ((< (LENGTH X)
(+ (COND (NIL-PAIRS 1) (T 0)) (LENGTH Y)))
(PAIRS1 (MAKE-POSSIBILITY-1 X
Y
FUN
APPLY-CONSTRAINTS
CONSTRAINTS
NIL-PAIRS)))
(T (PAIRS2 (MAKE-POSSIBILITY-2 Y
X
FUN
APPLY-CONSTRAINTS
CONSTRAINTS
NIL-PAIRS)))))))
(DEFUN MAKE-POSSIBILITY-1 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
((LAMBDA (N)
((LAMBDA (Q)
(COND
(NIL-PAIRS (MAPC (FUNCTION(LAMBDA (I) (RPLACD I
(LIST* '(NIL)
(CDR I)))))
Q))
(Q)))
(MAPCAN
(FUNCTION(LAMBDA (I)
(PROGN
(SETQ N 0)
((LAMBDA (A) (AND A
(OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(FUNCALL APPLY-CONSTRAINTS
CONSTRAINTS))
(LIST (LIST* I A))))
(MAPCAN
(FUNCTION(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (SETQ N (1+ N))
(COND ((OR (NULL FUN)
(FUNCALL FUN I J))
(LIST* N J)))))))
Y)))))
X)))
0))
(DEFUN MAKE-POSSIBILITY-2 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
NIL-PAIRS)
((LAMBDA (N)
((LAMBDA (Q)
(COND
(NIL-PAIRS (MAPC (FUNCTION(LAMBDA (I) (RPLACD I
(LIST* '(NIL)
(CDR I)))))
Q))
(Q)))
(MAPCAN
(FUNCTION(LAMBDA (I)
(PROGN
(SETQ N 0)
((LAMBDA (A) (AND A
(OR (NULL CONSTRAINTS)
(NULL APPLY-CONSTRAINTS)
(FUNCALL APPLY-CONSTRAINTS
CONSTRAINTS))
(LIST (LIST* I A))))
(MAPCAN
(FUNCTION(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (SETQ N (1+ N))
(COND ((OR (NULL FUN)
(FUNCALL FUN J I))
(LIST* N J)))))))
Y)))))
X)))
0))
(DEFUN PAIRS1 (L)
(COND
((NULL L) '((NIL)))
(T
((LAMBDA (CAND POSS)
(MAPCAN
(FUNCTION(LAMBDA (PAIRS)
(PROGN
((LAMBDA (AVOID ANS)
(MAPCAN
(FUNCTION(LAMBDA (I)
((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (COND ((CAR (MEMBER (CAR I)
AVOID))
(LIST* AVOID ANS))
(T (LIST* (LIST* (CAR I)
AVOID)
(LIST* CAND
(CDR I))
ANS)))))))
POSS))
(CAR PAIRS)
(CDR PAIRS)))))
(PAIRS1 (CDR L))))
(CAAR L)
(CDAR L)))))
(DEFUN PAIRS2 (L)
(COND
((NULL L) '((NIL)))
(T
((LAMBDA (CAND POSS)
(MAPCAN
(FUNCTION(LAMBDA (PAIRS)
(PROGN
((LAMBDA (AVOID ANS)
(MAPCAN
(FUNCTION(LAMBDA (I)
((LAMBDA (Q) (COND (Q (NCONS Q))))
(PROGN (COND ((CAR (MEMBER (CAR I)
AVOID))
(LIST* AVOID ANS))
(T (LIST* (LIST* (CAR I)
AVOID)
(LIST* (CDR I)
CAND)
ANS)))))))
POSS))
(CAR PAIRS)
(CDR PAIRS)))))
(PAIRS2 (CDR L))))
(CAAR L)
(CDAR L)))))
(declare (special a b))
(setq a '(
(1 2)
(7 8)
(9 0)
(a b c)
(a b c)
(d e f)
(d e f)
(g h i)
(g h i)
(j k l)
(m n o)
(p q r)
))
(setq b '(
(a b c)
(j k l)
(d e f)
(p q r)
(g h i)
(9 0)
(a b c)
(p q r)
(7 8)
(j k l)
(2 1)
(3 2)
(8 7)
(9 8)
(0 9)
(m n o)
(d e f)
(j k l)
(m n o)
(d e f)
(p q r)
(g h i)
))
(defun test ()
((lambda (t1 x gt)
(setq x (pairs a b () 'equal () () ()))
(setq t1 (- (runtime) t1))
(setq gt (- (status gctime) gt))
(print (length x))
(print (list 'runtime
(QUOTIENT (FLOAT (- t1 gt))
1000000.)))
(print (list 'gctime
(quotient (float gt) 1000000.))))
(runtime) ()(status gctime)))